home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / time.scm < prev    next >
Text File  |  1995-10-28  |  10KB  |  300 lines
  1. ;;; Time interface for scsh.
  2. ;;; Copyright (c) 1994 by Olin Shivers.
  3.  
  4. ;;; Should I have a (FILL-IN-DATE! date) procedure that fills in
  5. ;;; the redundant info in a date record?
  6. ;;; - month-day & month defined -> week-day & year-day filled in.
  7. ;;; - month-day and year-day filled in from week-day and year-day
  8. ;;;   (not provided by mktime(), but can be synthesized)
  9. ;;; - If tz-secs and tz-name not defined, filled in from current time zone.
  10. ;;; - If tz-name not defined, fabbed from tz-secs.
  11. ;;; - If tz-secs not defined, filled in from tz-name.
  12.  
  13. (foreign-source "#include \"time1.h\""    ; Import the time1.h interface.
  14.         "")
  15.  
  16. ;;; A TIME is an instant in the history of the universe; it is location
  17. ;;; independent, barring relativistic effects. It is measured as the
  18. ;;; number of seconds elapsed since "epoch" -- January 1, 1970 UTC.
  19.  
  20. ;;; A DATE is a *local* name for an instant in time -- which instant
  21. ;;; it names depends on your time zone (February 23, 1994 4:37 pm happens 
  22. ;;; at different moments in Boston and Hong Kong).
  23.  
  24. ;;; DATE definition
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26. ;;; We hack this so the date maker can take take the last three slots
  27. ;;; as optional arguments.
  28.  
  29. (define-record %date    ; A Posix tm struct
  30.   seconds    ; Seconds after the minute (0-59)
  31.   minute    ; Minutes after the hour (0-59)
  32.   hour       ; Hours since midnight (0-23)
  33.   month-day    ; Day of the month (1-31)
  34.   month       ; Months since January (0-11)
  35.   year        ; Years since 1900
  36.   tz-name    ; Time zone as a string.
  37.   tz-secs    ; Time zone as an integer: seconds west of UTC.
  38.   summer?    ; Summer time (Daylight savings) in effect?
  39.   week-day    ; Days since Sunday (0-6)    ; Redundant
  40.   year-day)    ; Days since Jan. 1 (0-365)    ; Redundant
  41.  
  42. (define date? %date?)
  43.  
  44. (define date:seconds    %date:seconds)
  45. (define date:minute    %date:minute)
  46. (define date:hour    %date:hour)
  47. (define date:month-day    %date:month-day)
  48. (define date:month    %date:month)
  49. (define date:year    %date:year)
  50. (define date:tz-name    %date:tz-name)
  51. (define date:tz-secs    %date:tz-secs)
  52. (define date:summer?    %date:summer?)
  53. (define date:week-day    %date:week-day)
  54. (define date:year-day    %date:year-day)
  55.  
  56. (define set-date:seconds    set-%date:seconds)
  57. (define set-date:minute        set-%date:minute)
  58. (define set-date:hour        set-%date:hour)
  59. (define set-date:month-day    set-%date:month-day)
  60. (define set-date:month        set-%date:month)
  61. (define set-date:year        set-%date:year)
  62. (define set-date:tz-name    set-%date:tz-name)
  63. (define set-date:tz-secs    set-%date:tz-secs)
  64. (define set-date:summer?    set-%date:summer?)
  65. (define set-date:week-day    set-%date:week-day)
  66. (define set-date:year-day    set-%date:year-day)
  67.  
  68. (define (make-date s mi h md mo y . args)
  69.   (receive (tzn tzs s? wd yd) (parse-optionals args #f #f #f 0 0)
  70.     (make-%date s mi h md mo y tzn tzs s? wd yd)))
  71.  
  72.  
  73. ;;; Not exported to interface.
  74. (define (time-zone? x)
  75.   (or (integer? x)    ; Seconds offset from UTC.
  76.       (string? x)    ; Time zone name, e.g. "EDT"
  77.       (not x)))        ; Local time
  78.  
  79.  
  80. ;;; Time
  81. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  82.  
  83. ; TICKS/SEC is defined in OS-dependent code.
  84.  
  85. (define-foreign %time+ticks/errno (time_plus_ticks)    ; C fun is OS-dependent
  86.   desc      ; errno or #f
  87.   fixnum  ; hi secs
  88.   fixnum  ; lo secs
  89.   fixnum  ; hi ticks
  90.   fixnum) ; lo ticks
  91.  
  92. (define (time+ticks)
  93.   (receive (err  hi-secs lo-secs hi-ticks lo-ticks) (%time+ticks/errno)
  94.     (if err (errno-error err time+ticks)
  95.     (values (compose-8/24 hi-secs   lo-secs)
  96.         (compose-8/24 hi-ticks  lo-ticks)))))
  97.  
  98. (define (time+ticks->time secs ticks)
  99.   (+ secs (/ ticks (ticks/sec))))
  100.  
  101. (define-foreign %time/errno (scheme_time)
  102.   desc      ; errno or #f
  103.   fixnum  ; hi secs
  104.   fixnum) ; lo secs
  105.  
  106.  
  107. (define-foreign %date->time/errno (date2time (fixnum sec)
  108.                          (fixnum min)
  109.                          (fixnum hour)
  110.                          (fixnum month-day)
  111.                          (fixnum month)
  112.                          (fixnum year)
  113.                          (desc   tz-name)    ; #f or string
  114.                          (desc   tz-secs)    ; #f or int
  115.                          (bool   summer?))
  116.   desc      ; errno or #f
  117.   fixnum  ; hi secs
  118.   fixnum) ; lo secs
  119.  
  120. (define (time . args) ; optional arg [date]
  121.   (receive (err hi-secs lo-secs)
  122.        (if (null? args)
  123.            (%time/errno) ; Fast path for (time).
  124.            (let ((date (check-arg date? (car args) time)))
  125.          (%date->time/errno (date:seconds   date)
  126.                     (date:minute    date)
  127.                     (date:hour      date)
  128.                     (date:month-day date)
  129.                     (date:month     date)
  130.                     (date:year      date)
  131.                     (date:tz-name   date)    ; #f or string
  132.                     (date:tz-secs   date)    ; #f or int
  133.                     (date:summer?   date))))
  134.  
  135.     (if err (apply errno-error err time args)
  136.     (compose-8/24 hi-secs lo-secs))))
  137.  
  138.  
  139. ;;; Date
  140. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  141. (define-foreign %time->date (time2date (fixnum time-hi)
  142.                        (fixnum time-lo)
  143.                        (desc zone))
  144.   desc        ; errno or #f
  145.   fixnum    ; seconds
  146.   fixnum    ; minute
  147.   fixnum    ; hour
  148.   fixnum    ; month-day
  149.   fixnum    ; month
  150.   fixnum    ; year
  151.   string    ; tz-name (#f if we need to make it from tz-secs)
  152.   fixnum    ; tz-secs
  153.   bool        ; summer?
  154.   fixnum    ; week-day
  155.   fixnum)    ; year-day
  156.  
  157.  
  158. (define (date . args)    ; Optional args [time zone]
  159.   (let ((time (if (pair? args)
  160.           (real->exact-integer (check-arg real? (car args) date))
  161.           (time)))
  162.     (zone (check-arg time-zone?
  163.              (and (pair? args) (optional-arg (cdr args) #f))
  164.              date)))
  165.     (receive (err seconds minute hour month-day month
  166.           year tz-name tz-secs summer? week-day year-day)
  167.          (%time->date (hi8 time) (lo24 time) zone)
  168.       (if err (errno-error err date time zone)
  169.       (make-%date seconds minute hour month-day month
  170.               year
  171.               (format-time-zone (or tz-name "UTC") tz-secs)
  172.               tz-secs summer? week-day year-day)))))
  173.  
  174.  
  175. ;;; Formatting date strings
  176. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  177.  
  178. (define (date->string date)    ; Sun Sep 16 01:03:52 1973
  179.   (format-date "~a ~b ~d ~H:~M:~S ~Y" date))
  180.  
  181. (define (format-date fmt date)
  182.   (check-arg date? date format-date)
  183.   (receive (err result)
  184.        (%format-date/errno fmt
  185.                    (date:seconds   date)
  186.                    (date:minute    date)
  187.                    (date:hour      date)
  188.                    (date:month-day date)
  189.                    (date:month     date)
  190.                    (date:year      date)
  191.                    (if (string? (date:tz-name date))
  192.                    (date:tz-name date)
  193.                    (deintegerize-time-zone (date:tz-secs date)))
  194.                    (date:summer?   date)
  195.                    (date:week-day  date)
  196.                    (date:year-day  date))
  197.     (if err (errno-error err format-date fmt date)
  198.     result)))
  199.  
  200. (define-foreign %format-date/errno (format_date (string fmt)
  201.                         (fixnum seconds)
  202.                         (fixnum minute)
  203.                         (fixnum hour)
  204.                         (fixnum month-day)
  205.                         (fixnum month)
  206.                         (fixnum year)
  207.                         (desc   tz-name)
  208.                         (bool   summer?)
  209.                         (fixnum week-day)
  210.                         (fixnum year-day))
  211.   desc        ; false or errno
  212.   string)
  213.  
  214.  
  215. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  216.  
  217. ;;; Obsoleted, since DATE records now include time zone info.
  218. ;;; If you want the UTC offset, just do (date:tz-secs (date [time tz])).
  219. ;;;
  220. ;(define (utc-offset . args) ; Optional args [time tz]
  221. ;  (let ((tim (if (pair? args)
  222. ;         (real->exact-integer (check-arg real? (car args) utc-offset))
  223. ;         (time)))
  224. ;    (tz (and (pair? args)
  225. ;         (check-arg time-zone? (optional-arg (cdr args) #f) utc-offset))))
  226. ;    (if (integer? tz) tz
  227. ;    (- (time (date tim tz) 0) tim))))
  228.  
  229.  
  230. ;(define (time-zone . args)    ; Optional args [summer? tz]
  231. ;  (let ((tz (and (pair? args)
  232. ;         (check-arg time-zone? (optional-arg (cdr args) #f) time-zone))))
  233. ;    (if (integer? tz)
  234. ;    (deintegerize-time-zone tz)
  235. ;    (let* ((summer? (if (pair? args) (car args) (time)))
  236. ;           (summer? (if (real? summer?) (real->exact-integer summer?) summer?)))
  237. ;      (receive (err zone) (%time-zone/errno summer? tz)
  238. ;           (if err (errno-error err time-zone summer? tz)
  239. ;        zone))))))
  240.          
  241. ;;; 8/24 bit signed integer splitting and recombination.
  242. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  243. (define (hi8  n) (bitwise-and (arithmetic-shift n -24) #xff))
  244. (define (lo24 n) (bitwise-and n #xffffff))
  245.  
  246. (define (compose-8/24 hi-8 lo-24)
  247.   (let ((val (+ (arithmetic-shift hi-8 24) lo-24)))
  248.     (if (zero? (bitwise-and hi-8 #x80)) val
  249.     ;; Oops -- it's a negative 32-bit value.
  250.     ;; Or in all the sign bits.
  251.     (bitwise-ior (bitwise-not #xffffffff)
  252.              val))))
  253.  
  254. ;;; Render a number as a two-digit base ten numeral. 
  255. ;;; Pathetic. FORMAT should do this for me.
  256. (define (two-digits n)
  257.   (let ((s (number->string n)))
  258.     (if (= (string-length s) 1)
  259.     (string-append "0" s)
  260.     s)))
  261.  
  262. ;;; If time-zone is an integer, convert to a Posix-format string of the form:
  263. ;;;     UTC+hh:mm:ss
  264. (define (deintegerize-time-zone tz)
  265.   (if (integer? tz)
  266.       (format-time-zone "UTC" tz)
  267.       tz))
  268.  
  269.  
  270. ;;; NAME is a simple time-zone name such as "EST" or "UTC". You get them
  271. ;;; back from the Unix time functions as the values of the char *tzname[2]
  272. ;;; standard/dst vector. The problem is that these time are ambiguous.
  273. ;;; This function makes them unambiguous by tacking on the UTC offset
  274. ;;; in Posix format, such as "EST+5". You need to do this for two reasons:
  275. ;;; 1. Simple time-zone strings are not recognised at all sites.
  276. ;;;    For example, HP-UX doesn't understand "EST", but does understand "EST+5"
  277. ;;; 2. Time zones represented as UTC offsets (e.g., "UTC+5") are returned
  278. ;;;    back from the Unix time software as just "UTC", which in the example
  279. ;;;    just given is 5 hours off. Try setting TZ=UTC+5 and running the date(1)
  280. ;;;    program. It will give you EST time, but print the time zone as "UTC".
  281. ;;;    Oops.
  282.  
  283. (define (format-time-zone name offset)
  284.   (if (zero? offset) name
  285.       (receive (sign offset)
  286.            (if (< offset 0)
  287.            (values #\+ (- offset))        ; Notice the flipped sign
  288.            (values #\- offset))            ; of SIGN.
  289.         (let* ((offset (modulo offset 86400))
  290.            (h (quotient offset 3600))
  291.            (m (quotient (modulo offset 3600) 60))
  292.            (s (modulo offset 60)))
  293.       (if (zero? s)
  294.           (if (zero? m)
  295.           (format #f "~a~a~d" name sign h)    ; name+h
  296.           (format #f "~a~a~a:~a"        ; name+hh:mm
  297.               sign (two-digits h) (two-digits m)))
  298.           (format #f "~a~a~a:~a:~a"            ; name+hh:mm:ss
  299.               sign (two-digits h) (two-digits m) (two-digits s)))))))
  300.